home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / write.scm < prev    next >
Text File  |  1995-10-13  |  5KB  |  152 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file write.scm.
  6.  
  7. ;;;; WRITE
  8.  
  9. ; To use this with some Scheme other than Scheme 48, do the following:
  10. ;  1. Copy the definition of output-port-option from port.scm
  11. ;  2. Define write-string as appropriate (as a write-char loop)
  12. ;  3. (define (disclose x) #f)
  13.  
  14. (define (write obj . port-option)
  15.   (let ((port (output-port-option port-option)))
  16.     (let recur ((obj obj))
  17.       (recurring-write obj port recur))))
  18.  
  19. (define (recurring-write obj port recur)
  20.   (cond ((null? obj) (write-string "()" port))
  21.         ((pair? obj) (write-list obj port recur))
  22.         ((eq? obj #t) (write-boolean 't port))
  23.         ((eq? obj #f) (write-boolean 'f port))
  24.         ((symbol? obj) (write-string (symbol->string obj) port))
  25.         ((number? obj) (write-number obj port))
  26.         ((string? obj) (write-string-literal obj port))
  27.         ((char? obj) (write-char-literal obj port))
  28.     (else (write-other obj port recur))))
  29.  
  30. (define (write-boolean mumble port)
  31.   (write-char #\# port)
  32.   (write mumble port))
  33.  
  34. (define (write-number n port)
  35.   (write-string (number->string n 10) port))
  36.  
  37. (define (write-char-literal obj port)
  38.   (let ((probe (character-name obj)))
  39.     (write-string "#\\" port)
  40.     (if probe
  41.     (write probe port)
  42.     (write-char obj port))))
  43.  
  44. (define (character-name char)
  45.   (cond ((char=? char #\space) 'space)
  46.         ((char=? char #\newline) 'newline)
  47.     (else #f)))
  48.  
  49. (define (write-string-literal obj port)
  50.   (write-char #\" port)
  51.   (let ((len (string-length obj)))
  52.     (do ((i 0 (+ i 1)))
  53.     ((= i len) (write-char #\" port))
  54.       (let ((c (string-ref obj i)))
  55.     (if (or (char=? c #\\) (char=? c #\"))
  56.         (write-char #\\ port))
  57.     (write-char c port)))))
  58.  
  59. (define (write-list obj port recur)
  60.   (cond ((quotation? obj)
  61.          (write-char #\' port)
  62.          (recur (cadr obj)))
  63.         (else
  64.          (write-char #\( port)
  65.          (recur (car obj))
  66.          (let loop ((l (cdr obj))
  67.                     (n 1))
  68.               (cond ((not (pair? l))
  69.                      (cond ((not (null? l))
  70.                             (write-string " . " port)
  71.                             (recur l))))
  72.                     (else
  73.                       (write-char #\space port)
  74.                       (recur (car l))
  75.                       (loop (cdr l) (+ n 1)))))
  76.          (write-char #\) port))))
  77.  
  78. (define (quotation? obj)
  79.   (and (pair? obj)
  80.        (eq? (car obj) 'quote)
  81.        (pair? (cdr obj))
  82.        (null? (cddr obj))))
  83.  
  84. (define (write-vector obj port recur)
  85.    (write-string "#(" port)
  86.    (let ((z (vector-length obj)))
  87.      (cond ((> z 0)
  88.             (recur (vector-ref obj 0))
  89.             (let loop ((i 1))
  90.               (cond ((>= i z))
  91.                     (else
  92.                      (write-char #\space port)
  93.                      (recur (vector-ref obj i))
  94.                      (loop (+ i 1))))))))
  95.    (write-char #\) port))
  96.  
  97. ; The vector case goes last just so that this version of WRITE can be
  98. ; used in Scheme implementations in which records, ports, or
  99. ; procedures are represented as vectors.  (Scheme 48 doesn't have this
  100. ; property.)
  101.  
  102. (define (write-other obj port recur)
  103.   (cond ((disclose obj)
  104.      => (lambda (l)
  105.           (write-string "#{" port)
  106.           (display-type-name (car l) port)
  107.           (for-each (lambda (x)
  108.               (write-char #\space port)
  109.               (recur x))
  110.             (cdr l))
  111.           (write-string "}" port)))
  112.     ((input-port? obj)  (write-string "#{Input-port}" port))
  113.     ((output-port? obj) (write-string "#{Output-port}" port))
  114.     ((eof-object? obj) (write-string "#{End-of-file}" port))
  115.     ((vector? obj) (write-vector obj port recur))
  116.     ((procedure? obj) (write-string "#{Procedure}" port))
  117.     ((eq? obj (if #f #f)) (write-string "#{Unspecific}" port))
  118.     (else
  119.      (write-string "#{Random object}" port))))
  120.  
  121. ; Display the symbol WHO-CARES as Who-cares.
  122.  
  123. (define (display-type-name name port)
  124.   (if (symbol? name)
  125.       (let* ((s (symbol->string name))
  126.          (len (string-length s)))
  127.     (if (and (> len 0)
  128.          (char-alphabetic? (string-ref s 0)))
  129.         (begin (write-char (char-upcase (string-ref s 0)) port)
  130.            (do ((i 1 (+ i 1)))
  131.                ((>= i len))
  132.              (write-char (char-downcase (string-ref s i)) port)))
  133.         (display name port)))
  134.       (display name port)))
  135.  
  136. ;(define (write-string s port)
  137. ;  (do ((i 0 (+ i 1)))
  138. ;      ((= i (string-length s)))
  139. ;    (write-char (string-ref s i) port)))
  140.  
  141.  
  142.  
  143. ; DISPLAY
  144.  
  145. (define (display obj . port-option)
  146.   (let ((port (output-port-option port-option)))
  147.     (let recur ((obj obj))
  148.       (cond ((string? obj) (write-string obj port))
  149.         ((char? obj) (write-char obj port))
  150.         (else
  151.          (recurring-write obj port recur))))))
  152.